;;;; © 2016-2020 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.type-inference)

;;; This file contains auxiliary functions for working with Common Lisp
;;; number types.

(defconstant short-float-e (exp 1S0))
(defconstant single-float-e (exp 1F0))
(defconstant double-float-e (exp 1D0))
(defconstant long-float-e (exp 1L0))
(defconstant short-float-pi (float pi 1S0))
(defconstant single-float-pi (float pi 1F0))
(defconstant double-float-pi (float pi 1D0))
(defconstant long-float-pi (float pi 1L0))

(defun slow-numeric-contagion (&rest ntypes)
  (labels ((initial-state ()
             (ntype-subtypecase (pop ntypes)
               ((not number) (ntype 'nil))
               (short-float (short-float-state))
               (single-float (single-float-state))
               (double-float (double-float-state))
               (long-float (long-float-state))
               (float (float-state))
               (integer (integer-state))
               (rational (rational-state))
               (real (real-state))
               ((complex short-float) (complex-short-float-state))
               ((complex single-float) (complex-single-float-state))
               ((complex double-float) (complex-double-float-state))
               ((complex long-float) (complex-long-float-state))
               (complex (complex-state))
               (t (number-state))))
           (short-float-state ()
             (if (null ntypes)
                 (ntype 'short-float)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (short-float-state))
                   (single-float (single-float-state))
                   (double-float (double-float-state))
                   (long-float (long-float-state))
                   (float (float-state))
                   (integer (short-float-state))
                   (rational (short-float-state))
                   (real (real-state))
                   ((complex short-float) (complex-short-float-state))
                   ((complex single-float) (complex-single-float-state))
                   ((complex double-float) (complex-double-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (single-float-state ()
             (if (null ntypes)
                 (ntype 'single-float)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (single-float-state))
                   (single-float (single-float-state))
                   (double-float (double-float-state))
                   (long-float (long-float-state))
                   (float (float-state))
                   (integer (single-float-state))
                   (rational (single-float-state))
                   (real (real-state))
                   ((complex short-float) (complex-single-float-state))
                   ((complex single-float) (complex-single-float-state))
                   ((complex double-float) (complex-double-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (double-float-state ()
             (if (null ntypes)
                 (ntype 'double-float)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (double-float-state))
                   (single-float (double-float-state))
                   (double-float (double-float-state))
                   (long-float (long-float-state))
                   (float (float-state))
                   (integer (double-float-state))
                   (rational (double-float-state))
                   (real (real-state))
                   ((complex short-float) (complex-double-float-state))
                   ((complex single-float) (complex-double-float-state))
                   ((complex double-float) (complex-double-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (long-float-state ()
             (if (null ntypes)
                 (ntype 'long-float)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (long-float-state))
                   (single-float (long-float-state))
                   (double-float (long-float-state))
                   (long-float (long-float-state))
                   (float (float-state))
                   (integer (long-float-state))
                   (rational (long-float-state))
                   (real (real-state))
                   ((complex short-float) (complex-long-float-state))
                   ((complex single-float) (complex-long-float-state))
                   ((complex double-float) (complex-long-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (float-state ()
             (if (null ntypes)
                 (ntype 'float)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (float-state))
                   (single-float (float-state))
                   (double-float (float-state))
                   (long-float (float-state))
                   (float (float-state))
                   (integer (float-state))
                   (rational (float-state))
                   (real (real-state))
                   ((complex short-float) (complex-state))
                   ((complex single-float) (complex-state))
                   ((complex double-float) (complex-state))
                   ((complex long-float) (complex-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (integer-state ()
             (if (null ntypes)
                 (ntype 'integer)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (short-float-state))
                   (single-float (single-float-state))
                   (double-float (double-float-state))
                   (long-float (long-float-state))
                   (float (float-state))
                   (integer (integer-state))
                   (rational (rational-state))
                   (real (real-state))
                   ((complex short-float) (complex-short-float-state))
                   ((complex single-float) (complex-single-float-state))
                   ((complex double-float) (complex-double-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (rational-state ()
             (if (null ntypes)
                 (ntype 'rational)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (short-float-state))
                   (single-float (single-float-state))
                   (double-float (double-float-state))
                   (long-float (long-float-state))
                   (float (float-state))
                   (integer (rational-state))
                   (rational (rational-state))
                   (real (real-state))
                   ((complex short-float) (complex-short-float-state))
                   ((complex single-float) (complex-single-float-state))
                   ((complex double-float) (complex-double-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (real-state ()
             (if (null ntypes)
                 (ntype 'real)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (real-state))
                   (single-float (real-state))
                   (double-float (real-state))
                   (long-float (real-state))
                   (float (real-state))
                   (integer (real-state))
                   (rational (real-state))
                   (real (real-state))
                   ((complex short-float) (complex-state))
                   ((complex single-float) (complex-state))
                   ((complex double-float) (complex-state))
                   ((complex long-float) (complex-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (complex-short-float-state ()
             (if (null ntypes)
                 (ntype '(complex short-float))
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (complex-short-float-state))
                   (single-float (complex-single-float-state))
                   (double-float (complex-double-float-state))
                   (long-float (complex-long-float-state))
                   (float (complex-state))
                   (integer (complex-short-float-state))
                   (rational (complex-short-float-state))
                   (real (complex-state))
                   ((complex short-float) (complex-short-float-state))
                   ((complex single-float) (complex-single-float-state))
                   ((complex double-float) (complex-double-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (complex-single-float-state ()
             (if (null ntypes)
                 (ntype '(complex single-float))
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (complex-single-float-state))
                   (single-float (complex-single-float-state))
                   (double-float (complex-double-float-state))
                   (long-float (complex-long-float-state))
                   (float (complex-state))
                   (integer (complex-single-float-state))
                   (rational (complex-single-float-state))
                   (real (complex-state))
                   ((complex short-float) (complex-single-float-state))
                   ((complex single-float) (complex-single-float-state))
                   ((complex double-float) (complex-double-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (complex-double-float-state ()
             (if (null ntypes)
                 (ntype '(complex double-float))
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (complex-double-float-state))
                   (single-float (complex-double-float-state))
                   (double-float (complex-double-float-state))
                   (long-float (complex-long-float-state))
                   (float (complex-state))
                   (integer (complex-double-float-state))
                   (rational (complex-double-float-state))
                   (real (complex-state))
                   ((complex short-float) (complex-double-float-state))
                   ((complex single-float) (complex-double-float-state))
                   ((complex double-float) (complex-double-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (complex-long-float-state ()
             (if (null ntypes)
                 (ntype '(complex long-float))
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (short-float (complex-long-float-state))
                   (single-float (complex-long-float-state))
                   (double-float (complex-long-float-state))
                   (long-float (complex-long-float-state))
                   (float (complex-state))
                   (integer (complex-long-float-state))
                   (rational (complex-long-float-state))
                   (real (complex-state))
                   ((complex short-float) (complex-long-float-state))
                   ((complex single-float) (complex-long-float-state))
                   ((complex double-float) (complex-long-float-state))
                   ((complex long-float) (complex-long-float-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (complex-state ()
             (if (null ntypes)
                 (ntype 'complex)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (float (complex-state))
                   (integer (complex-state))
                   (rational (complex-state))
                   (real (complex-state))
                   (complex (complex-state))
                   (t (number-state)))))
           (number-state ()
             (if (null ntypes)
                 (ntype 'number)
                 (ntype-subtypecase (pop ntypes)
                   ((not number) (ntype 'nil))
                   (t (number-state))))))
    (initial-state)))

(defun numeric-contagion (ntype-1 ntype-2)
  (with-ntype-caching (ntype-1 ntype-2)
    (slow-numeric-contagion ntype-1 ntype-2)))

(defun complex-part-ntype (ntype)
  (ntype-subtypecase ntype
    ((not complex) (ntype 'nil))
    ((complex short-float) (ntype 'short-float))
    ((complex single-float) (ntype 'single-float))
    ((complex double-float) (ntype 'double-float))
    ((complex long-float) (ntype 'long-float))
    (t (ntype 'real))))

